(require "set.ss"
         "ordered.ss"
         (prefix list: (lib "list.ss" "mzlib")))

(define elm-eq? =)

(define modulo-order@
  (unit/sig ordered^
    (import)
    (define (elm= a b)  (= (modulo a 2) (modulo b 2)))
    (define (elm< a b)  (< (modulo a 2) (modulo b 2)))
    (define (elm<= a b) (<= (modulo a 2) (modulo b 2)))))

; We represent the refined set as an unordered set of equivalence classes.


(define (order->unordered-list-order@ element-order@)
  ; An element order induces an order on unorded lists
  ; of equivalent elements.
  (let ((order-on-unordered-lists@ 
         (unit/sig ordered^
           (import ordered^)
           (rename (class= elm=) (class< elm<) (class<= elm<=))
           (define (class= A B)
             (or (and (null? A) (null? B))
                 (elm= (car A) (car B))))
           (define (class< A B)
             (cond
               [(null? A) (not (null? B))]
               [(null? B) #f]
               [else      (elm< (car A) (car B))]))
           (define (class<= A B)
             (or (class< A B)
                 (class= A B))))))
    (compound-unit/sig
      (import)
      (link (ALPHA        : ordered^ (element-order@))
            (ALPHA-CLASS  : ordered^ (order-on-unordered-lists@ ALPHA)))
      (export (open ALPHA-CLASS)))))
  
(define class-order@ (order->unordered-list-order@ modulo-order@))

(use-set (instantiate-set ordered-list-set@ class-order@) class)
(use-set (instantiate-set unordered-list-set@ elm-eq?) ul)


(define empty class:empty)

(define (singleton x)
  (class:singleton (list x)))

(define (set . xs)
  (let loop ([xs xs]
             [cs class:empty])
    (cond
      [(null? xs) cs]
      [else       (insert1 (car xs) cs)])))

(define (union A B)
  (class:fold A B (lambda (ca B)
                    (let ([cb (member ca B)])
                      (if cb
                          (class:insert1 (ul:union ca cb)
                                         (class:remove1 cb B))
                          (class:insert1 ca B))))))

(define (intersection A B)
  (class:fold A class:empty
              (lambda (ca akk)
                (let ([cb (member ca B)])
                  (if cb
                      (class:insert1 (ul:intersection ca cb)
                                     (class:remove1 cb akk))
                      akk)))))

(define (difference A B)
  (class:fold B A
              (lambda (cb A)
                (let ([ca (member cb A)])
                  (if ca
                      (class:insert1 (ul:difference ca cb)
                                     (class:remove1 ca A))
                      A)))))

(define empty? class:empty?)

(define (member? x A)
  (class:member? (list x) A))

(define (member x A)
  (class:member (list x) A))

(define (subset? A B)
  (let/ec return
    (class:fold A #t
                (lambda (ca i)
                  (let ([cb (class:member ca B)])
                    (cond
                      [(ul:empty? ca)              #t]
                      [(and cb (ul:subset? ca cb)) #t]
                      [else                        (return #f)]))))))

(define (equal? A B)
  (and (= (size A) (size B))
       (subset? A B)
       (subset? B A)))

(define (insert A . xs)
  (list:fold xs A
             (lambda (x A)
               (insert1 x A))))

(define (insert1 x A)
  (let ([ca (class:member (list x) A)])
    (cond
      [(and ca (ul:member? x ca))  A]
      [ca                          (class:insert1 (ul:insert1 x ca)
                                                  (class:remove1 (list x)))]
      [else                        (class:insert1 (list x)
                                                  A)])))

(define (remove A . xs)
  (list:fold xs A
             (lambda (x A)
               (remove1 x A))))

(define (remove1 x A)
  (let ([ca (class:member (list x) A)])
    (if ca
        (class:insert1 (ul:remove1 x ca)
                       (class:remove1 (list x) ca))
        A)))

(define (size A)
  (class:fold A 0
              (lambda (ca s)
                (+ (class:size ca s)))))

(define (fold f b A)
  (class:fold A b
              (lambda (ca akk)
                (ul:fold ca akk f))))

(define (elements A)
  (fold A '() cons))


(define (set? o)
  (class:set? o))
